home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / ccc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-10-06  |  10.1 KB  |  431 lines
  1. /* ******************************************************************** */
  2. /* ccc.c             Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Comparing, copying and conversion.                                   */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: ccc.c,v 1.8 1992/02/27 15:49:10 pab Exp $
  9.  *
  10.  * $Log: ccc.c,v $
  11.  * Revision 1.8  1992/02/27  15:49:10  pab
  12.  * lose type_condition
  13.  *
  14.  * Revision 1.7  1992/01/21  22:38:31  pab
  15.  * Fixed equal on structs
  16.  *
  17.  * Revision 1.6  1992/01/17  22:25:49  pab
  18.  * Added conversion+copy methods
  19.  *
  20.  * Revision 1.5  1992/01/09  22:28:44  pab
  21.  * Fixed for low tag ints
  22.  *
  23.  * Revision 1.4  1991/12/22  15:13:53  pab
  24.  * Xmas revision
  25.  *
  26.  * Revision 1.3  1991/11/15  13:44:25  pab
  27.  * copyalloc rev 0.01
  28.  *
  29.  * Revision 1.2  1991/09/11  12:07:03  pab
  30.  * 11/9/91 First Alpha release of modified system
  31.  *
  32.  * Revision 1.1  1991/08/12  16:49:29  pab
  33.  * Initial revision
  34.  *
  35.  * Revision 1.4  1991/02/14  10:07:28  kjp
  36.  * Added an eq lisp function handle for table optimisation.
  37.  *
  38.  * Revision 1.3  1991/02/14  05:59:24  kjp
  39.  * Fixed Fn_equal in the symbol case.
  40.  *
  41.  */
  42.  
  43. /*
  44.  * Change Log:
  45.  *   Version 1, March 1990 (Compiler rationalisation)
  46.  */
  47.  
  48. #include <stdio.h>
  49. #include <string.h>
  50. #include "funcalls.h"
  51. #include "defs.h"
  52. #include "structs.h"
  53.  
  54. #include "error.h"
  55. #include "global.h"
  56.  
  57. #include "calls.h"
  58. #include "modboot.h"
  59. #include "ngenerics.h"
  60.  
  61. LispObject function_eq;
  62.  
  63. EUFUN_2( Fn_eq, x, y)
  64. {
  65.   if (x == y) 
  66.     return(lisptrue);
  67.   else
  68.     return(nil);
  69. }
  70. EUFUN_CLOSE
  71.  
  72. /* Non-generic, hacked equal */
  73.  
  74. LispObject equal_lookup_table;
  75.  
  76. EUFUN_2( Fn_equal, x, y)
  77. {
  78.   while (TRUE) {
  79.     if (x == y) return lisptrue;
  80.     if (typeof(x) != typeof(y)) return nil;
  81.     switch (typeof(x)) {
  82.     case TYPE_CONS:
  83.       if (EUCALL_2(Fn_equal, CAR(x), CAR(y))) {
  84.     ARG_0(stackbase) = x = CDR(ARG_0(stackbase));
  85.     ARG_1(stackbase) = y = CDR(ARG_1(stackbase));
  86.     continue;
  87.       }
  88.       else return nil;
  89.     case TYPE_CHAR:
  90.       if ((((x->CHAR).code) == ((y->CHAR).code)) &&
  91.       (((x->CHAR).font) == ((y->CHAR).font))) return lisptrue;
  92.       else return nil;
  93.     case TYPE_STRING:
  94.       if (strcmp(stringof(x),stringof(y)) == 0) return lisptrue;
  95.       else return nil;
  96.     case TYPE_SYMBOL:
  97.       return nil;
  98.     case TYPE_TABLE:
  99.     case TYPE_THREAD:
  100.     case TYPE_STREAM:
  101.       CallError(stacktop,"Unimplemented facility in equal",nil,NONCONTINUABLE);
  102.     case TYPE_INT:
  103.       if (intval(x) == intval(y)) return lisptrue;
  104.       else return nil;
  105.     case TYPE_FLOAT:
  106.       if ((x->FLOAT).fvalue == (y->FLOAT).fvalue) return lisptrue;
  107.       else return nil;
  108.     case TYPE_RATIONAL:
  109.       if (EUCALL_2(Fn_equal,(x->RATIO).numerator,(y->RATIO).numerator)) {
  110.     x = ARG_0(stackbase); y = ARG_1(stackbase);
  111.     if (EUCALL_2(Fn_equal,(x->RATIO).denominator,(y->RATIO).denominator))
  112.       return lisptrue;
  113.     else return nil;
  114.       }
  115.       else return nil;
  116.     case TYPE_COMPLEX:
  117.       if (EUCALL_2(Fn_equal,(x->COMPLEX).real,(y->COMPLEX).real)) {
  118.     x = ARG_0(stackbase); y = ARG_1(stackbase);
  119.     if (EUCALL_2(Fn_equal,(x->COMPLEX).imaginary,(y->COMPLEX).imaginary))
  120.       return lisptrue;
  121.     else return nil;
  122.       }
  123.       else return nil;
  124.     default:
  125.       {
  126.     LispObject foo = allocate_integer(stacktop,(int) typeof(x));
  127.     LispObject ans;
  128.     EUCALLSET_2(ans, Fn_tref, equal_lookup_table, foo);
  129.     x = ARG_0(stackbase); y = ARG_1(stackbase);
  130.     if (null(ans))
  131.       (void) CallError(stacktop,
  132.                "equal: No method for ~a", x, NONCONTINUABLE);
  133.     return EUCALL_3(apply2,ans,x,y);
  134.       }
  135.     }
  136.   }
  137.  
  138.   return(nil); /* dummy */
  139.  
  140. }
  141. EUFUN_CLOSE
  142.  
  143. /* Non-generic hacked copy */
  144.  
  145. EUFUN_1( Fn_copy, form)
  146. {
  147.   switch (typeof(form)) 
  148.     {
  149.     case TYPE_NULL:
  150.       return(nil);
  151.     case TYPE_INT:
  152.       return allocate_integer(stacktop,intval(form));
  153.     case TYPE_SYMBOL:
  154.       return form;
  155.     case TYPE_TABLE:
  156.       return EUCALL_1(table_copy,form);
  157.     case TYPE_CONS:
  158.       {
  159.     LispObject xx, yy;
  160.     EUCALLSET_1(xx, Fn_copy, CAR(form));
  161.     EUCALLSET_1(yy, Fn_copy, CDR(ARG_0(stackbase)));
  162.     return EUCALL_2(Fn_cons,xx, yy);
  163.       }
  164.     default:
  165.       (void) CallError(stacktop,
  166.                "copy: No method for ~a", form, NONCONTINUABLE);
  167.     }
  168.  
  169.   return(nil); /* dummy */
  170.  
  171. }
  172. EUFUN_CLOSE
  173.  
  174. /* ******************************************************************** */
  175. /*                          Generic Copying                             */
  176. /* ******************************************************************** */
  177.  
  178. static LispObject generic_copy;
  179.  
  180. EUFUN_1( Gf_copy, obj)
  181. {
  182.   return(generic_apply_1(stacktop,generic_copy,obj));
  183. }
  184. EUFUN_CLOSE
  185.  
  186. EUFUN_1( Md_copy_Object, obj)
  187. {
  188.   return(Fn_copy(stackbase));
  189. }
  190. EUFUN_CLOSE
  191.  
  192. #ifndef NO_COMPACT
  193. #define myvref(v,i) vref(v,i)
  194. #else
  195. #define vrefupdate(v,i,obj) (*(&(v->VECTOR.base)+i)=obj)
  196. #define myvref(v,i) (*(&(v->VECTOR.base)+i))
  197. #endif
  198.  
  199. EUFUN_1( Md_copy_Pair, p)
  200. {
  201.   LispObject new;
  202.  
  203.   if (p == nil) return(nil);
  204.   
  205.   new = (is_cons(CDR(p)) ? EUCALL_1(Gf_copy,CDR(p)) : CDR(p));
  206.   p = ARG_0(stackbase);
  207.   return EUCALL_2( Fn_cons, CAR(p), new);
  208. }
  209. EUFUN_CLOSE
  210.  
  211. EUFUN_1( Md_copy_Vector, v)
  212. {
  213.   LispObject new;
  214.   int i;
  215.  
  216.   new = (LispObject) allocate_vector(stacktop,v->VECTOR.length);
  217.   v = ARG_0(stackbase);
  218.   for (i=0; i<v->VECTOR.length; ++i) {
  219.     vrefupdate(new,i,myvref(v,i));
  220.   }
  221.  
  222.   return(new);
  223. }
  224. EUFUN_CLOSE
  225.  
  226. EUFUN_1( Md_copy_Structure, str)
  227. {
  228.   LispObject new;
  229.  
  230.  
  231. #ifdef dunno /* Tue Jul 23 12:06:58 1991 */
  232. /**/  STACK(str);
  233. /**/  if (typeof(str) != TYPE_INSTANCE) return(Fn_copy(/*+:NULL:+*/str));
  234. /**/  new = allocate_instance(classof(str));
  235. /**/  STACK(new);
  236. /**/  new->INSTANCE.slots = Gf_copy(str->INSTANCE.slots);
  237. /**/  UNSTACK(2);
  238. #endif /* dunno Tue Jul 23 12:06:58 1991 */
  239.   
  240.   return(str);
  241. }
  242. EUFUN_CLOSE
  243.  
  244. /* ******************************************************************** */
  245. /*                          Generic Equality                            */
  246. /* ******************************************************************** */
  247.  
  248. LispObject generic_equal;
  249.  
  250. EUFUN_2( Gf_equal, o1, o2)
  251. {
  252.   return(generic_apply_2(stacktop,generic_equal,o1,o2));
  253. }
  254. EUFUN_CLOSE
  255.  
  256. /* Basic methods... */
  257.  
  258. EUFUN_2( Md_equal_Object_Object, o1, o2)
  259. {
  260.   /* Same class? */
  261.  
  262.   if (classof(o1) != classof(o2)) return(nil);
  263.  
  264.   /* Same type? */
  265.  
  266.   if (typeof(o1) != typeof(o2)) return(nil);
  267.  
  268.   /* Instance? */
  269.  
  270. /**
  271.   if (typeof(o1) == TYPE_INSTANCE) {
  272.     if (Gf_equal(o1->INSTANCE.slots,o2->INSTANCE.slots) == nil) {
  273.       UNSTACK(2);
  274.       return(nil);
  275.     }
  276.     else {
  277.       UNSTACK(2);
  278.       return(lisptrue);
  279.     }
  280.   }
  281.   **/
  282.  
  283.   return(Fn_equal(stackbase));
  284. }
  285. EUFUN_CLOSE
  286.  
  287. EUFUN_2( Md_equal_Pair_Pair, p1, p2)
  288. {
  289.   LispObject xx;
  290.   if (p1 == p2) return(lisptrue);
  291.   if (p1 == nil) return(nil);
  292.   if (p2 == nil) return(nil);
  293.  
  294.   if (EUCALL_2(Gf_equal,CAR(p1),CAR(p2)) == nil)
  295.     return nil;
  296.   p1 = ARG_0(stackbase); p2 = ARG_1(stackbase);
  297.   if (EUCALL_2(Gf_equal,CDR(p1),CDR(p2)) == nil)
  298.     return(nil);
  299.   else
  300.     return(lisptrue);
  301. }
  302. EUFUN_CLOSE
  303.  
  304. EUFUN_2( Md_equal_Vector_Vector, v1, v2)
  305. {
  306.   int i;
  307.  
  308.   if (v1->VECTOR.length != v2->VECTOR.length) return(nil);
  309.  
  310.   for (i=0; i<v1->VECTOR.length; ++i) {
  311.     if (EUCALL_2(Gf_equal,myvref(v1,i),myvref(v2,i)) == nil) return(nil);
  312.     v1 = ARG_0(stackbase); v2 = ARG_1(stackbase);
  313.   }
  314.   
  315.   return(lisptrue);
  316. }
  317. EUFUN_CLOSE
  318.  
  319. EUFUN_2( Md_equal_Structure_Structure, s1, s2)
  320. {
  321.   int i;
  322.   LispObject res;
  323.  
  324.   if (EUCALL_2(Gf_equal,classof(s1),classof(s2)) == nil) 
  325.     return  nil;
  326.   
  327.   for (i=0; i<classof(s1)->CLASS.local_count ; i++)
  328.     {
  329.       if (slotref(s1,i)!=slotref(s2,i))
  330.     return nil;
  331.       i++;
  332.     }
  333.  
  334.   return lisptrue;
  335.   
  336. }
  337. EUFUN_CLOSE
  338.  
  339. EUFUN_2( Md_equal_Class_Class, c1, c2)
  340. {
  341.   return((c1 == c2 ? lisptrue : nil));
  342. }
  343. EUFUN_CLOSE
  344.  
  345.  
  346. /* ******************************************************************** */
  347. /*                          Generic Conversion                          */
  348. /* ******************************************************************** */
  349.  
  350. EUFUN_1( Md_generic_convert_Pair_Vector, l1)
  351. {
  352.   LispObject walker;
  353.   LispObject new;
  354.   int i;
  355.  
  356.   if (l1 == nil) return(nil);
  357.   new = (LispObject)
  358.           allocate_vector(stacktop,intval(EUCALL_1(Fn_length,l1)));
  359.  
  360.   l1 = ARG_0(stackbase);
  361.   for (i=0,walker = l1; is_cons(walker); ++i,walker = CDR(walker)) 
  362.     vrefupdate(new,i,CAR(walker));
  363.  
  364.   return(new);
  365. }
  366. EUFUN_CLOSE
  367.  
  368. EUFUN_1( Md_generic_convert_Vector_Pair, v1)
  369. {
  370.   extern LispObject Fn_convert_vector_list(LispObject*);
  371.   
  372.   return(Fn_convert_vector_list(stackbase));
  373. }
  374. EUFUN_CLOSE
  375.  
  376. #define CCC_ENTRIES 14
  377. MODULE Module_ccc;
  378. LispObject Module_ccc_values[CCC_ENTRIES];
  379.  
  380. void initialise_ccc(LispObject *stacktop)
  381. {
  382.   extern LispObject Basic_Structure;
  383.  
  384.   open_module(stacktop,
  385.           &Module_ccc,
  386.           Module_ccc_values,
  387.           "ccc",
  388.           CCC_ENTRIES);
  389.  
  390.   function_eq = make_module_function(stacktop,"eq",Fn_eq,2);
  391.   add_root(&function_eq);
  392.  
  393.   EUCALLSET_1(equal_lookup_table, Fn_make_table,nil);
  394.   generic_equal = make_wrapped_module_generic(stacktop,"equal",2,Gf_equal);
  395.   add_root(&generic_equal);
  396.   (void) make_module_function(stacktop,"generic_equal,Cons,Cons",
  397.                   Md_equal_Pair_Pair,2
  398.                   );
  399.   (void) make_module_function(stacktop,"generic_equal,Object,Object",
  400.                   Md_equal_Object_Object,2
  401.                   );
  402.   (void) make_module_function(stacktop,"generic_equal,Vector,Vector",
  403.                   Md_equal_Vector_Vector,2
  404.                   );
  405.   (void) make_module_function(stacktop,"generic_equal,Basic_Structure,Basic_Structure",
  406.                   Md_equal_Structure_Structure,2
  407.                   );
  408.   (void) make_module_function(stacktop,"generic_equal,Standard_Class,Standard_Class",
  409.                   Md_equal_Class_Class,2
  410.                   );
  411.  
  412.   generic_copy = make_wrapped_module_generic(stacktop,"copy",1,Gf_copy);
  413.   add_root(&generic_copy);
  414.   (void) make_module_function(stacktop,"generic_copy,Object",Md_copy_Object,1);
  415.   (void) make_module_function(stacktop,"generic_copy,Cons",Md_copy_Pair,1);
  416.   (void) make_module_function(stacktop,"generic_copy,Vector",Md_copy_Vector,1);
  417.   (void) make_module_function(stacktop,
  418.                   "generic_copy,Basic_Structure",Md_copy_Structure,1);
  419.  
  420.   /* conversion methods */
  421.   (void) make_module_function(stacktop,"generic_generic_convert,Cons,Vector",
  422.                   Md_generic_convert_Pair_Vector,1
  423.                   );
  424.   (void) make_module_function(stacktop,"generic_generic_convert,Vector,Cons",
  425.                   Md_generic_convert_Vector_Pair,1
  426.                   );
  427.  
  428.   close_module();
  429. }
  430.  
  431.